perm filename PICIO.SAI[2,DBL] blob
sn#023359 filedate 1973-01-29 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
RECORD PAGE DESCRIPTION
00001 00001
00002 00002 ENTRY SNDPIC
00005 00003 INTEGER CHN
00008 00004 INTERNAL PROCEDURE PICTOSEG(PICTURE PICINTEGER SEGNAMSTRING TITLE)
00013 00005 INTERNAL PROCEDURE DDCALL(PICTURE PICSTRING TITLE,COMS)
00017 00006 INTERNAL STRING PROCEDURE RECPIC(PICTURE PICINTEGER MODESTRING FILE)
00020 ENDMK
⊗;
ENTRY SNDPIC;
BEGIN"PICIO"
REQUIRE "PROLOG.HDR[1,PDQ]" SOURCE_FILE;
REQUIRE "COMSUB.HDR[1,PDQ]" SOURCE_FILE;
INTEGER BCLIP,TCLIP,BITS,IWID,LINLEN,FLINE,LLINE,LSIDE,RSIDE,SIZE,TVWORD;
INTERNAL STRING GLBNAM; ⊃ GLOBAL FILE NAME FOR THE * OPTION;
INTERNAL SIMPROC QTOHE(PICTURE PIC);
⊃ Conversion from Quam format picture header array to hand-eye
library style parameters;
BEGIN IWID←PIC[SIZEX];FLINE←PIC[POSY];LSIDE←PIC[POSX];
RSIDE←LSIDE+IWID-1;LLINE←FLINE+PIC[SIZEY]-1;
LINLEN←PIC[SIZEL];BITS←PIC[BIT];SIZE←LINLEN*PIC[SIZEY];
BCLIP←PIC[OFFSET];TCLIP←PIC[GAIN];
END "QTOHE";
INTERNAL SIMPROC HETOQ(PICTURE PIC);
⊃ Conversion from hand-eye library parameters to Quam format picture
header array;
BEGIN PIC[SCALEX]←PIC[SCALEY]←1;
PIC[POSX]←LSIDE;PIC[POSY]←FLINE;
PIC[SIZEX]←RSIDE-LSIDE+1;PIC[SIZEY]←LLINE-FLINE+1;
PIC[SIZEL]←HAT(PIC[SIZEX],36 DIV BITS);
PIC[BIT]←BITS;
IF ABS(TCLIP)≤30 THEN BEGIN PIC[GAIN]←0;PIC[OFFSET]←0;END
ELSE BEGIN PIC[GAIN]←TCLIP;PIC[OFFSET]←BCLIP;END;
END "HETOQ";
DEFINE SNAM="'13",LNAM="'14";
INTEGER SIMPROC LEFT(INTEGER WD);
START_CODE HLRE 1,WD;END;
INTEGER CHN;
PROCEDURE DSKLD(INTEGER DADR,ADR);
BEGIN INTEGER BLK,WD;DEFINE BLKSIZ="'200";
INTEGER ARRAY TEMP[0:BLKSIZ];
BLK←DADR DIV BLKSIZ;WD←DADR MOD BLKSIZ;
USETI(CHN,BLK+1);IF WD>0 THEN ARRYIN(CHN,TEMP[0],WD);
START_CODE
DEFINE P="'17";
MOVE 1,ADR;HRRZ 2,-1(1);
PUSH P,CHN;PUSH P,1;PUSH P,2;
PUSHJ P,ARRYIN;
END;
END "DSKLD";
STRING PROCEDURE STRLD(INTEGER IOWD);
BEGIN INTEGER WDS,DADR;
IF (WDS←-LEFT(IOWD))≤0 THEN RETURN(NULL);
DADR←IOWD LAND '777777;
BEGIN INTEGER_ARRAY SBUF[1:WDS];
DSKLD(DADR,LOC(SBUF[1]));
RETURN(MAKSTR(SBUF[1],5*WDS));
END;
END;
INTERNAL INTEGER SIMPROC STRIOWD(STRING S;REFERENCE INTEGER SLOC);
BEGIN INTEGER SLNG,SWDS,WD;
SLNG←LENGTH(S);SWDS←HAT(SLNG,5);
WD←XWD(-SWDS,SLOC);SLOC←SLOC+SWDS;
RETURN(WD);
END;
INTERNAL PROCEDURE STRFIL(STRING STR;PROCEDURE OUTER);
BEGIN INTEGER STRWDS,STRLNG;STRWDS←HAT("STRLNG←LENGTH(∪TR)",5);
IF STRWDS=0 THEN RETURN;
BEGIN INTEGER ARRAY SBUF[1:STRWDS];
UNSTR(STR,POINT(7,SBUF[1],-1),STRLNG);
OUTER(LOC(SBUF[1]));
END;
END;
INTERNAL INTEGER SIMPROC PARGET(PICTURE PIC;INTEGER_ARRAY HEADER);
BEGIN INTEGER I;
BITS←HEADER[1];ARRBLT(LINLEN,HEADER[2],5);
BCLIP←HEADER['40];TCLIP←HEADER['41];
HETOQ(PIC);
FOR I←7 STEP 1 UNTIL 14 DO
IF HEADER[I]≠0 THEN RETURN(HEADER[I] LAND '777777);
OUTSTR("ILLEGAL PICTURE FORMAT"&CRLF);
END;
INTERNAL INTEGER PROCEDURE GETPARS(PICTURE PIC;INTEGER CHAN);
IF (BCLIP←WORDIN(CHN←CHAN))≠-1 THEN
BEGIN
ARRYIN(CHN,TCLIP,9); ⊃ Input picture parameters;
HETOQ(PIC);
RETURN(10);
END ELSE
BEGIN
INTEGER_ARRAY HEADER[1:'177];
INTEGER LOC;
ARRYIN(CHN,HEADER[1],'177);
LOC←PARGET(PIC,HEADER);
SETNAM(PIC,STRLD(HEADER[SNAM]));
SETITLE(PIC,STRLD(HEADER[LNAM]));
RETURN(LOC);
END "GETPARS";
INTERNAL PROCEDURE PICTOSEG(PICTURE PIC;INTEGER SEGNAM;STRING TITLE);
⊃ Transfers the picture described by PIC to a 2nd segment whose
SIXBIT name is SEGNAM;
BEGIN
INTEGER SLOC,SGNAM;
SIMPROC SEGFIL(REFERENCE INTEGER ADR);
SLOC←SLOC+ATOSEG(SGNAM,ADR,SLOC);
STRING TITLE,NAM;
TITLE←GETITLE(PIC);
SGNAM←SEGNAM;
NAM←GETNAM(PIC);
BEGIN INTEGER ARRAY HEADER[0:31];
INTEGER TEMP;
ARRBLT(HEADER[0],PIC[0],PICMAX+1);
SLOC←'400000+32;
HEADER[PICMAX+1]←STRIOWD(NAM,SLOC);
HEADER[PICMAX+2]←STRIOWD(TITLE,SLOC);
SLOC←'400000;
TEMP←LOC(HEADER[0]);
SEGFIL(TEMP); ⊃ Transfer the header parameters;
STRFIL(NAM,SEGFIL);
STRFIL(TITLE,SEGFIL);
END;
IF PIC[PTR] THEN
SEGFIL(PIC[PTR]); ⊃ Transfer the picture;
END "PICTOSEG";
INTERNAL STRING PROCEDURE SEGTOPIC(PICTURE PIC;INTEGER SEGNAM;BOOLEAN KILL);
⊃ Transfers the picture from the 2nd segment whose SIXBIT name is
SEGNAM to picture header PIC. The 2nd segment is killed if KILL is
true. Returns the name of the 2nd segment;
BEGIN INTEGER ARRAY HEADER[0:31];
INTEGER SLOC,NLNG,NLNGS,TLNG,TLNGS;
BOOLEAN FLG;
STRING NAM,TITLE;
PICREL(PIC);
FLG←SEGTOA(SEGNAM,LOC(HEADER[0]),SLOC←'400000); ⊃ Get the header parameters;
IF ¬FLG THEN BEGIN USERERR(0,1,CVXSTR(SEGNAM)&" NON-EX SEGMENT NAME ");
RETURN(NULL);END;
ARRBLT(PIC[0],HEADER[0],PICMAX+1);
PIC[NAME]←0;
TLNG←-LEFT(HEADER[PICMAX+2]);
NLNG←-LEFT(HEADER[PICMAX+1]);
SLOC←SLOC+32;
IF TLNG+NLNG>0 THEN
BEGIN INTEGER ARRAY SBLK[1:TLNG+NLNG];
SEGTOA(SEGNAM,LOC(SBLK[1]),SLOC);
NAM←MAKSTR(SBLK[1],5*NLNG);
TITLE←MAKSTR(SBLK[1+NLNG],5*TLNG);
END;
SETNAM(PIC,NAM);SETITLE(PIC,TITLE);
PIC[PTR]←0;PICMAK(PIC); ⊃ Allocate array space;
IF PIC[PTR] THEN
SEGTOA(SEGNAM,PIC[PTR],SLOC←SLOC+TLNG+NLNG); ⊃ Get the picture;
IF KILL THEN KILSEG(SEGNAM); ⊃ And if KILL=TRUE kill the 2nd segment;
RETURN(NAM); ⊃ And return the NAM of the segment;
END "SEGTOPIC";
INTERNAL STRING PROCEDURE PICPARS(PICTURE PIC;STRING NAM);
BEGIN
INTEGER PICCHN;BOOLEAN FLG;
STRING EXT,PPN,NAM2;
LABEL FOUND;
OPEN(PICCHN←GETCHAN,"DSK",'10,1,0,0,0,0);
FOR EXT←NULL,".TMP",".DAT" DO
FOR PPN←NULL,"[1,PDQ]","[M71,RBT]","[1,BO]","[001,MJH]" DO
BEGIN LOOKUP(PICCHN,NAM2←NAM&EXT&PPN,FLG);
IF ¬FLG THEN BEGIN NAM←NAM2;GO TO FOUND;END;
END;
WHILE FLG DO BEGIN NAM←STRIN(NAM&" NOT FOUND, FILE←");
LOOKUP(PICCHN,NAM,FLG);
END;
FOUND: SETBREAK(1,".[",NULL,"INS");NAM2←NAM;
IF GETPARS(PIC,PICCHN)=10 THEN
BEGIN SETNAM(PIC,SCAN(NAM2,1,0));SETITLE(PIC,NAM);END;
RELEASE(PICCHN);
RETURN(NAM);
END "PICPARS";
INTERNAL PROCEDURE PICFORM(STRING PICNAM;REFERENCE INTEGER PPL,LINES);
BEGIN INTEGER C;C←LOP(PICNAM);
IF C="6"∨C="7" THEN BEGIN PPL←974;LINES←775;END
ELSE BEGIN PPL←832;LINES←700;END;
END;
INTERNAL PROCEDURE DDCALL(PICTURE PIC;STRING TITLE,COMS);
BEGIN SAFE_OWN INTEGER ARRAY PARS[1:14];
INTEGER ARRAY LETTER[1:32];
INTEGER NO;
⊃ REQUIRE "SWAPER[1,PDQ]" LOAD_MODULE;
⊃ EXTERNAL STRING PROCEDURE JOBCALL(STRING SAVEJOB,CALLJOB;⊃ INTEGER ARRAY PARS);
WHILE SEGXISTS(PARS[1]←CVSIX("DDPIC")) DO WAIT(1);
PICTOSEG(PIC,PARS[1],TITLE);
UNSTR("iDDPIC"&CRLF&COMS&CRLF&"R"&CRLF,POINT(7,LETTER[1],-1),5*32);
IF (NO←JOBNUMBER("DDVID"))=0 THEN BEGIN OUTSTR("NO DDVID"&CRLF);RETURN;END;
IF CANMAIL(NO) THEN SNDMAIL(LETTER,NO)
ELSE OUTSTR("DDVID BUSY"&CRLF);
⊃ JOBCALL("DDSAV.RPG","DDSUB[1,PDQ]",PARS);
END "DDCALL";
INTERNAL PROCEDURE SNDPIC(PICTURE PIC;STRING TITLE,DEST);
⊃ This is the general purpose picture output procedure, which will
transfer a picture to any of three different destinations specified
by the parameter DEST. DEST=@<FOO> specifies the Data Disk video
synthesizer.
Other non-NULL values of DEST specify a disk file. TITLE is a string
describing the picture, which the display programs output with the
picture. PIC is or course the picture header array;
BEGIN
IF DEST="@" THEN DDCALL(PIC,TITLE,DEST[2 TO ∞])
ELSE IF DEST THEN ⊃ Otherwise, output picture to a disk file;
BEGIN INTEGER CHN,ADR,SLOC; ⊃ in hand-eye library format;
INTEGER ARRAY HDR[0:'177];
INTEGER TEMP,FLG;
STRING NAM;
SIMPROC DSKFIL(REFERENCE INTEGER A);
START_CODE
DEFINE P="'17";
MOVE 1,A;HRRZ 2,-1(1);
ADDM 2,SLOC;
PUSH P,CHN;PUSH P,1;PUSH P,2;PUSHJ P,ARRYOUT;
END;
QTOHE(PIC);
OPEN(CHN←GETCHAN,"DSK",'10,0,11,0,0,0);
IF DEST="*" THEN DEST←GLBNAM&DEST[2 TO ∞];
WHILE TRUE DO
BEGIN ENTER(CHN,DEST,FLG);
IF ¬FLG THEN DONE;
DEST←STRIN(DEST&" ILLEGAL FILE NAME, FILE←");
END;
HDR[0]←-1;HDR[1]←BITS;ARRBLT(HDR[2],LINLEN,5);
NAM←GETNAM(PIC);TITLE←GETITLE(PIC);
SLOC←'200;
HDR[SNAM]←STRIOWD(NAM,SLOC);HDR[LNAM]←STRIOWD(TITLE,SLOC);
HDR[7]←XWD(-PIC[SIZEL]*PIC[SIZEY],SLOC);
HDR['40]←PIC[OFFSET];HDR['41]←PIC[GAIN];
SLOC←0;
TEMP←LOC(HDR[0]);
DSKFIL(TEMP);
STRFIL(NAM,DSKFIL);
STRFIL(TITLE,DSKFIL);
DSKFIL(PIC[PTR]);
RELEASE(CHN);
END;
END "SNDPIC";
INTERNAL STRING PROCEDURE RECPIC(PICTURE PIC;INTEGER MODE;STRING FILE);
⊃ This is the general purpose picture input program which can receive
pictures from two different sources. If FILE=@ then RECPIC will wait
for mail specifying a 2nd segment containing a picture to input. If
MODE=0 then RECPIC will restart the calling job on the next call to
RECPIC. If FILE≠@ then RECPIC will input a hand-eye library format
picture file. PIC is of course the picture header array where the
picture is put. RECPIC returns the title of the picture if there is
one, otherwise FILE;
BEGIN
STRING TITLE;
INTEGER FLG,ADR,EOF,I,PST;LABEL L;
PICREL(PIC);
OPEN(CHN←GETCHAN,"DSK",'10,2,0,0,0,EOF);
IF FILE="*" THEN FILE←GLBNAM&FILE[2 TO ∞];
L:LOOKUP(CHN,FILE,FLG);
IF FLG THEN BEGIN FILE←STRIN("FILE=");GO TO L;END;
PST←GETPARS(PIC,CHN);
PICMAK(PIC);DSKLD(PST,PIC[PTR]);
IF PST=10 THEN
BEGIN
INTEGER_ARRAY MESS[1:32];
FOR I←5 STEP 1 UNTIL 32 DO
BEGIN MESS[I]←WORDIN(CHN);IF EOF∨MESS[I]=0 THEN DONE;END; ⊃ Input TITLE;
SETNAM(PIC,TITLE←MKSTR(MESS,5));
END ELSE TITLE←GETNAM(PIC);
RELEASE(CHN);
IF PIC[GAIN]=0 THEN PIC[GAIN]←PSCALE;
RETURN(IF TITLE THEN TITLE ELSE FILE); ⊃ If no TITLE, return FILE name;
END "RECPIC";
END "PICIO";